perm filename SCANR.F4[M11,LCS] blob
sn#439858 filedate 1979-05-08 generic text, type T, neo UTF8
C ***** SCANNER *************************
C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,POINTR,PARAM,ALL 7/78
SUBROUTINE SCANR
DIMENSION IP(15)
C IP LIMITS NUMBER OF DIGITS IN A FLOATING POINT NUM.
COMMON J,L /DUR/DUR(27) /ALPH/IALPH(14),ISCA(12),IDAT(11)
1/E/IQ(27),ISKP,XMINUS,AN,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG
1 ,VX(70),IAMP,K,KN,M,ML,CODE /INP/INP(1)
1 /BLA/IBLA,KSLA,ISEMI,MINUS,ISTAR,ICOMM,ICOL,IQUES,ILESS,IQT
EQUIVALENCE(IFF,ISCA(6)),(ISS,ISCA(9)),(IEE,ISCA(5)),
1 (IDOT,IDAT(11)),(III,IALPH(2)),(IRR,IALPH(9)),(IXX,IALPH(13))
1 ,(INN,ISCA(4)),(IP,PL),(I0,IDAT),(I9,IDAT(10)),(IPP,ISCA(2))
NNUM=-1
ISKP=0
JJ=0
XMINUS=1.
KPAR=0
999 IDECI=-1
M=0
2799 N=INP(ML)
IF(N.NE.IQT)GO TO 899
JA=-1
ML=ML+1
ISUB=8
JJ=JJ+1
VX(JJ)=ML
C POINTS TO FIRST LIT. CHAR.
DO 1177 K=ML,144
IF(INP(K).NE.IQT)GO TO 1177
ML=K+1
2177 N=INP(ML)
GO TO 899
1177 CONTINUE
C SKIPS 'LIT' ITEMS IN RAN. SELECTION
899 ML=ML+1
IF(N.EQ.ICOL)GO TO 751
IF(N.EQ.ISEMI)GO TO 751
IF(N.NE.IBLA)GO TO 510
4702 IF(ISKP)202,2799,2799
510 IF(N.NE.IPP)GO TO 4511
C CATCH PARAM NUMS. GO UP AND CHANGE TO MAGIC NUMBER.
K=INP(ML)
IF(K.LT.I0.OR.K.GT.I9)GO TO 4511
KPAR=-1
JA=0
C JA=0 SO SCANR WILL FIND NOTES OR NUMS LATER.
GO TO 2177
4511 IF(JA)GO TO 70
DO 77 K=1,12
IF(N.NE.ISCA(K))GO TO 77
IF(K.EQ.2)GO TO 1511
C P=PROXIMITY MODE -- OR A PARAM NUM.
C ERROR IF NO NUM AFTER P WHEN ONLY NUMS ARE EXPECTED.
C FINDS PARAMETER NUMBER (E.G. P13) USED AS A SIMPLE NUMBER. (KPAR IS FLAG)
1510 IF(K.NE.4)GO TO 511
C K=2=P, =4=O ('ORDINARY')
1511 NSWCH=K-4
GO TO 2177
C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
511 NNUM=K
JJ=JJ+1
NFLG=-1
N=INP(ML)
IF(N.NE.IFF)GO TO 410
NNUM=NNUM-1
GO TO 610
410 IF(N.NE.ISS)GO TO 3410
NNUM=NNUM+1
610 ML=ML+1
N=INP(ML)
3410 IF(N.EQ.INN)GO TO 3411
IF(N.NE.III)GO TO 371
C 'END' OR 'FINE' WILL END INST.
3411 VX(JJ)=-10000.
IF(DUR(LK).LT.0)DUR(LK)=10000.
IAMP=-1
RETURN
371 IF(N.EQ.ISEMI)GO TO 5410
IF(N.EQ.IBLA)GO TO 5410
DO 177 KN=1,10
IF(N.NE.IDAT(KN))GO TO 177
JSCA=KN-1
ML=ML+1
GO TO 2410
177 CONTINUE
GO TO 6410
5410 KN=-1
6410 IF(NSWCH.EQ.0)GO TO 2410
IF(KN.LT.0)GO TO 7410
C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
7410 IF(NOLD-NNUM.LE.5)GO TO 7411
IF(JSCA.LT.7)JSCA=JSCA+1
7411 IF(NOLD-NNUM.GE.-5)GO TO 2410
IF(JSCA.GT.0)JSCA=JSCA-1
C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
2410 VX(JJ)=JSCA*12+NNUM
NOLD=NNUM
4410 NNUM=-2
IF(INP(ML).EQ.ISEMI)RETURN
C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
IF(N.EQ.IXX)GO TO 210
IF(N.EQ.ISTAR)GO TO 210
GO TO 310
77 CONTINUE
70 IF(N.NE.MINUS)GO TO 71
XMINUS=-1.
GO TO 2799
210 JJ=JJ+1
IF(JJ.EQ.1)GO TO 3310
XMINUS=1.
VX(JJ)=0
C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
GO TO 310
71 IF(N.EQ.IXX)GO TO 210
IF(N.EQ.ISTAR)GO TO 210
IF(N.EQ.IRR)GO TO 73
1410 DO 78 K=1,11
IF(N.NE.IDAT(K))GO TO 78
ISKP=-1
IF(N.NE.IDOT)GO TO 79
IDECI=M
GO TO 75
79 M=M+1
IP(M)=K-1
GO TO 75
78 CONTINUE
IF(N.NE.IEE)GO TO 8811
IF(INP(ML).NE.INN)GO TO 781
GO TO 7811
8811 IF(N.NE.IFF)GO TO 781
IF(INP(ML).NE.III)GO TO 781
C 'EN(D)' OR 'FI(NE)' WILL END INST.
7811 JJ=1
GO TO 3411
781 IF(N.EQ.KSLA)N=ISEMI
C FOR MOTIVIC TRANFORMATIONS
75 KN=INP(ML)
275 IF(KN.NE.IXX)GO TO 175
C "X(" STARTS A 'MOTIF' BUT "X (" WON'T WORK!!!!
IF(M.NE.0)GO TO 202
175 IF(KN.EQ.ISTAR)GO TO 202
C FOR 2X3, 2*3, ETC. CHECK THIS OUT. 6/74
C FOR 'X' AND '*' WITHOUT SPACES.
IF(N.EQ.ISEMI)GO TO 751
IF(KN.EQ.IQT)GO TO 751
C SO YOU CAN TYPE .5"F7" ETC. (NO SPACE)
IF(KN.NE.1)GO TO 2799
C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
751 IF(ISKP.EQ.0)RETURN
202 IF(IDECI.NE.-1)GO TO 302
IDECI=0
GO TO 402
302 IDECI=M-IDECI
402 KN=0
IEXP=M-1
IF(M.LT.1)M=1
DO 171 K=1,M
KV=10**IEXP
IF(IEXP.EQ.0)KV=1
KN=KN+IP(K)*KV
171 IEXP=IEXP-1
A=10**IDECI
IF(IDECI.EQ.0)A=1.
JJ=JJ+1
A=KN/A*XMINUS
CC VX(JJ)=KN/A*XMINUS
IF(KPAR.EQ.0)GO TO 172
A=-9999.-A/100.
KPAR=0
C CHANGES P13 TO -9999.13, FOR EXAMPLE.
172 VX(JJ)=A
IF(ISUB.EQ.1)RETURN
IF(CODE.NE.-22.)XMINUS=1.
C ONLY ONE - NEEDED FOR RHY.COMPOSITE
1310 IF(INP(ML).NE.1)GO TO 310
VX(JJ+1)=VX(JJ)*2.
JJ=JJ+1
ML=ML+1
GO TO 1310
206 ML=ML+2
3310 VX(1)=-99.
310 ISKP=0
IF(N.NE.ISEMI)GO TO 999
RETURN
73 JJ=JJ+1
IF(INP(ML).EQ.IEE)GO TO 206
C NEXT IS FOR A REST ('R')
VX(JJ)=199.
731 N=INP(ML)
IF(N.EQ.KSLA)RETURN
IF(N.EQ.ISEMI)RETURN
IF(N.NE.IBLA)GO TO 899
ML=ML+1
GO TO 731
END
SUBROUTINE RANR(VX,K)
C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE AND ADDS .999
DIMENSION VX(1)
J=K+1
IF(VX(K).GT.VX(K+1))J=J-1
IF(VX(J).GT.-9999.)VX(J)=VX(J)+.999
C AVOID TAMPERING WITH PARAM NUMS.
END
SUBROUTINE COLTTY(JNP,JT)
COMMON /BLA/IBLA
DIMENSION JNP(1)
DO 1 K=72,1,-1
JJ=JNP(K)
1 IF(JJ.NE.IBLA)GO TO 2
C SECOND SPACE IS A TAB.
K=1
2 IF(JT.NE.20)GO TO 5
WRITE(JT,10)(JNP(L),L=1,K)
C WRITES 'TYPED' INPUT INTO FILE 'TYPD.DAT'
RETURN
5 WRITE(JT,11)(JNP(L),L=1,K)
10 FORMAT(80A1)
11 FORMAT(1X,80A1)
END
FUNCTION READER(JNP)
DIMENSION JNP(80)
COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
COMMON /TYP/JOUT,LN,KTYPE /ITYP/ITYP,JED /BLA/IBLA
READER=0
IF(ITYP.LT.0)GO TO 1
2203 FORMAT(' TYPE A LINE'/)
6 WRITE(JTYPE,2203)
READ(JTYPE,10)JNP
IF(JED.LT.0)CALL COLTTY(JNP,20)
GO TO 8
CKL1 IF(LN.NE.0)GO TO 5
1 READ(ID23,10,END=3)JNP
IF(JNP(1).EQ.IBLA)GO TO 1
C IF 1ST CHAR. IS BLANK, GO READ ANOTHER LINE.
GO TO 7
3 READER=-1
RETURN
CKL5 READ(ID23,11,END=3)LN,JNP
7 IF(KTYPE.EQ.0)CALL COLTTY(JNP,JOUT)
8 CALL CLEAN(LEND)
10 FORMAT(80A1)
CKL11 FORMAT(I,80A1)
END
SUBROUTINE CLEAN(LEND)
COMMON /E/IQ(27),ISKP,XMINUS,AN,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,
1 VX(70),IAMP,J,KN,JO,ML,CODE
1 /INP/INP(1) /ALPH/IALPH(14),ISCA(12),IDAT(11)
1 /BLA/IBLA,KSLA,ISEMI,MINUS,ISTAR,ICOMM,ICOL,IQUES,ILESS
EQUIVALENCE (IAA,ISCA(10)),(IZZ,ISCA(7))
C CLEAR THE END OF ARRAY
M=72
LEND=-1
K=0
DO 10 LL=73,80
IF(INP(LL).EQ.IBLA)GO TO 10
C THIS 'ERR' IS JUST A WARNING
CALL ERR(11)
GO TO 1
10 CONTINUE
1 K=K+1
NN=INP(K)
IF(NN.EQ.ISEMI)GO TO 2
IF(NN.EQ.KSLA)GO TO 2
IF(NN.EQ.ILESS)GO TO 3
C USE < FOR COMMENT-- AS IN MUS10
5 IF(NN.EQ.ICOMM)INP(K)=IBLA
CHANGE ALL COMMAS TO BLANKS
C**** FOR CHORD FEATURE IF(NN.EQ.':')CALL ERR(1)
8 IF(NN.NE.IQT)GO TO 4
7 K=K+1
IF(INP(K).EQ.IQT)GO TO 4
IF(K.LT.M)GO TO 7
CALL ERR(5)
2 LEND=K
4 IF(K.LT.M)GO TO 1
3 IF(LEND.EQ.0)GO TO 9
IF(LEND.GT.0)RETURN
9 IF(M.EQ.145)CALL ERR(2)
C LINES STARTING WITH P OR C CAN POSSIBLY HAVE NO SEMICOLON IN THEM.
6 CALL READER(INP(74))
C GO READ ANOTHER LINE.
M=INP(74)
IF(M.GE.IAA.AND.M.LE.IZZ)CALL ERR(2)
C ONE EXTRA SPACE (M=145, NOT 144) FOR THE CRLF.
M=145
K=72
INP(73)=IBLA
GO TO 1
END
SUBROUTINE ERR(K)
COMMON /ERRFLG/ERRFLG /TYP/JOUT /E/IQ(27),ISKP,XMINUS,AN,
1 IEXP,LK,NNUM,JJ,JA,ISUB,NFLG
1 /INP/INP(74)
COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
WRITE(JTYPE,999)INP
IF(K.LE.0)GO TO 998
GO TO(1,2,3,4,5,6,7,8,9,10,11,12,13)K
998 WRITE(JTYPE,199)K
199 FORMAT(' ***** ERROR!! SOMEWHERE UP TO HERE. ***-FATAL-***'/)
GO TO 200
1 WRITE(JTYPE,101)
GO TO 200
101 FORMAT(' ***** COLON WANTED HERE? ***-FATAL-***'/)
CCC11 FORMAT(/' ILLEGAL COLON')
2 WRITE(JTYPE,102)
GO TO 200
102 FORMAT(' ***** NO END MARK OR SEMICOLON ***-FATAL-***'/)
3 WRITE(JTYPE,103)
GO TO 200
103 FORMAT(' ***** MORE THAN 2 PARENS OPEN ***-FATAL-***'/)
4 WRITE(JTYPE,104)
GO TO 200
104 FORMAT(' ***** SOME NUMBER OUT OF BOUNDS ***-FATAL-***'/)
5 WRITE(JTYPE,105)
GO TO 200
105 FORMAT(' ***** OPEN QUOTES ***-FATAL-***'/)
6 WRITE(JTYPE,106)
GO TO 200
106 FORMAT(' ***** PARAM NUMBER ERROR: >99 ***-FATAL-***'/)
7 WRITE(JTYPE,107)
GO TO 200
107 FORMAT(' ***** TOO MANY INSTS ***-FATAL-***'/)
8 WRITE(JTYPE,108)
GO TO 200
108 FORMAT(' ***** MOTIVE ERROR ***-FATAL-***'/)
9 WRITE(JTYPE,109)
GO TO 200
109 FORMAT(' ***** "MOVE" ERROR ***-FATAL-***'/)
10 WRITE(JTYPE,110)
GO TO 200
110 FORMAT(' ***** MISSING "*" ***-FATAL-***'/)
11 WRITE(JTYPE,111)
RETURN
111 FORMAT(' **** WARNING: CHARACTERS FOUND BEYOND COLUMN 72'/)
12 WRITE(JTYPE,112)
GO TO 200
999 FORMAT(1X74A1)
112 FORMAT(
1' ***** WRONG NUM. OF ELEMENTS IN RAN. SELECTION. ***-FATAL-***'/)
13 WRITE(JTYPE,113)
113 FORMAT(' ***** WRONG FORMAT FOR P2. ***-FATAL-***'/)
200 ERRFLG=-1
C THIS WILL CAUSE EXIT BEFORE 'RUNIT'.
END
SUBROUTINE SHORT(KNP,K)
C DON'T TYPE TRAILING BLANKS
DIMENSION KNP(1)
COMMON /BLA/IBLA
DO 1 K=15,1,-1
1 IF(KNP(K).NE.IBLA)RETURN
K=1
END